home *** CD-ROM | disk | FTP | other *** search
/ The Best of MacTutor - S…e Code for Volumes 1 to 5 / The Best of MacTutor - Source Code for Volume 1-5 (Wayzata Technology)(6031)(1990).bin / Source Code / #26 (Nov 87) / Forth Multifinder / V3#11 source
Text File  |  1987-09-04  |  6KB  |  264 lines
  1. \ © 1987 J.Langowski / MacTutor
  2. \ with parts of the code © Palo Alto Shipping
  3. \ add this code to the IOTASK code supplied by 
  4. \ Palo Alto Shipping, and modify main event loop as indicated
  5.  
  6. .TRAP    _WaitNextEvent    $A860
  7.  
  8. CODE WaitNextEvent 
  9.     ( eventMask VAR-eventRecord sleep mouseRgn -- flag )
  10.     EXG    D4,A7
  11.     CLR.W    -(A7)        \ function result
  12.     MOVE.W  $E(A6),-(A7)    \ eventMask
  13.     MOVE.L    $8(A6),-(A7)    \ eventRecord
  14.     MOVE.L    $4(A6),-(A7)    \ sleep
  15.     MOVE.L      (A6),-(A7)    \ mouseRgn
  16.     ADDA.W    #$10,A6
  17.     _WaitNextEvent
  18.     MOVE.W    (A7)+,D0    \ flag -> D0
  19.     EXT.L    D0        \ extend sign
  20.     MOVE.L    D0,-(A6)    \ push on Forth stack
  21.     EXG    D4,A7
  22.     RTS
  23. END-CODE
  24.  
  25. Header JugglerThere -1 ,    \ initially -1 so that first call
  26.                 \ to GetNextEvent will determine state
  27.  
  28. \  ========= The Main Loop  ===========
  29.  
  30. : DialogEvent? (  -  f  )
  31.     \ If the event is a dialog event which should be handled
  32.     \ by our application 
  33.     \ (usually be being passed to DialogSelect),
  34.     \ IsDialogEvent will return a true flag.  If the event
  35.     \ should be handled as a normal, non-dialog event, false
  36.     \ will be returned.
  37.     EVENT-RECORD CALL IsDialogEvent ;
  38.     
  39. : GetNextEvent (  - f )
  40.     \ If an event occurs which should be handled,
  41.      \ GetNextEvent will return a true flag.  
  42.     \ The event code and any other event information 
  43.     \ will be returned in the EVENT-RECORD.
  44.     \ changed for Juggler support 26.8.87 JL
  45.     ['] JugglerThere @ CASE
  46.     1     OF    \ Yes, we can juggle
  47.         EveryEvent Event-Record 1 0 WaitNextEvent 
  48.         ENDOF
  49.      0     OF   \ no, we can't
  50.         CALL SystemTask 
  51.         \ built in here since WaitNextEvent doesn't need it
  52.         EveryEvent Event-Record CALL GetNextEvent  
  53.         ENDOF
  54.     -1     OF    WNETrap#     CALL GetTrapAddress
  55.             UnkTrap#     CALL GetTrapAddress
  56.         = IF CALL SystemTask 0 
  57.         ELSE 1 THEN 
  58.         ['] JugglerThere !
  59.         EveryEvent EVENT-RECORD CALL GetNextEvent 
  60.         ENDOF
  61.     0     \ we should never get here
  62.     ENDCASE
  63. ;
  64.     
  65.     
  66. \ ===== (IOTASK) =====
  67.     
  68. : (IOTask) {  | dialogflag eventflag --  }
  69.     BEGIN
  70.         BEGIN
  71.             GetNextEvent    -> eventflag
  72.             DialogEvent?    -> dialogflag
  73.  
  74.             dialogflag    IF
  75.                 HandleDialog
  76.             ELSE
  77.                 eventflag    IF  HandleEvent  THEN
  78.             THEN
  79.         eventflag 0=
  80.         UNTIL
  81.         PAUSE
  82.     AGAIN ;
  83.         
  84.  
  85. \ Reflections
  86. \ Mach2.12 Demo
  87. \ 6/87
  88. \ Palo Alto Shipping Company
  89.  
  90. \ Description: 
  91. \ (xx1,yy1) and (xx2,yy2) are two points that travel around the
  92. \ reflections window. Their speeds are the delta values held in the
  93. \ DOT variables. When a point runs into a wall, it's x or y speed is
  94. \ negated so that it bounces off the wall. All the while a line is 
  95. \ drawn between the two points and the line drawn 20 steps ago is \ erased.
  96.   
  97. ONLY FORTH DEFINITIONS    ALSO MAC
  98. DECIMAL
  99.  
  100. \ QuickDraw Equates
  101. $8    CONSTANT PatCopy
  102. $B    CONSTANT PatBic
  103. $10    CONSTANT PortRect
  104.  
  105. \ Window Size Variables
  106. VARIABLE    WTop
  107. VARIABLE    WLeft
  108. VARIABLE    WBottom
  109. VARIABLE    WRight
  110. VARIABLE    WWidth
  111. VARIABLE    WHeight
  112.  
  113. \ Positions    \ Velocities
  114. VARIABLE xx1    VARIABLE xx1DOT
  115. VARIABLE yy1    VARIABLE yy1DOT
  116. VARIABLE xx2    VARIABLE xx2DOT
  117. VARIABLE yy2    VARIABLE yy2DOT
  118.  
  119. \ Menu constants and variables.
  120. VARIABLE DeskName 252 VALLOT
  121.  
  122. $44525652 CONSTANT 'DRVR'
  123.  
  124. CREATE AppleString    \ Creating title string for AppleMenu.
  125. $01 C,            \ Length byte.
  126. $14 C,             \ Apple character.
  127.  
  128. \ Creating a window named 'Reflections'.
  129. NEW.WINDOW                Reflections    " Reflections"                Reflections TITLE
  130. #115 #315 #265 #465            Reflections BOUNDS
  131. ROUNDED VISIBLE NOCLOSEBOX NOGROWBOX
  132.     Reflections ITEMS
  133.  
  134. \ 'LinesTask' is a task w/ 800 bytes of parameter stack.
  135. #800 #1000 TERMINAL LinesTask
  136.  
  137. \ Give 'Reflections' a menubar.
  138. NEW.MBAR ReflectMBar
  139.  
  140. NEW.MENU        AppleMenu
  141. AppleString        AppleMenu TITLE
  142. 0 #998            AppleMenu BOUNDS
  143. " (Reflections;(-"    AppleMenu ITEMS
  144.  
  145. NEW.MENU    FileMenu
  146. " File"        FileMenu TITLE
  147. 0 #999        FileMenu BOUNDS
  148. " Quit/Q"    FileMenu ITEMS
  149.  
  150. : HandleDeskAcc { item# | saveport --  }
  151.     ^ saveport CALL GetPort
  152.     AppleMenu @ item# DeskName CALL GetItem    
  153.     DeskName CALL OpenDeskAcc DROP
  154.     saveport CALL SetPort  ;
  155.  
  156. : DoApple ( item# -  ) HandleDeskAcc ;
  157.  
  158. : DoFile ( item# -  ) DROP BYE ;    
  159.     
  160. : MbarHandler  ( item# menuID -  )
  161.     CASE
  162.         #998 OF DoApple    ENDOF
  163.         #999 OF DoFile    ENDOF
  164.     ENDCASE  
  165.     0 CALL HiliteMenu  ;
  166.  
  167. : RANGE { value hi lo - value flag }
  168.     value hi value > lo value < OR NOT ;
  169.     
  170. : 4DUP ( n1 n2 n3 n4 - n1 n2 n3 n4 n1 n2 n3 n4 )
  171.     #3 pick #3 pick #3 pick #3 pick ;
  172.     
  173. : GetWCoords { wptr | wrect --  }
  174.     wptr PortRect + -> wrect
  175.     wrect        W@ L_EXT WTop     !
  176.     wrect 2+        W@ L_EXT WLeft     !
  177.     wrect 4 +    W@ L_EXT WBottom !
  178.     wrect 6 +    W@ L_EXT WRight  !
  179.  
  180.     WBottom @    WTop @ -     WHeight !
  181.     WRight @    WLeft @ -     WWidth !  ;
  182.     
  183. : Exit? ( - f ) 
  184.     ?TERMINAL IF
  185.         KEY IF BYE THEN
  186.     THEN ;
  187.  
  188. : SetupReflect (  -  )
  189.     Reflections CALL SetPort 
  190.     CLS
  191.     WWidth    @ 3 /     xx1 !   #3 xx1DOT !
  192.     WHeight @         yy1 !  #-4 yy1DOT !
  193.     WWidth    @ 3 / 2*     xx2 !   #4 xx2DOT !
  194.     WHeight @         yy2 !  #-3 yy2DOT ! ;
  195.     
  196. \ Draws a newline and leaves coords on stack.
  197. : NewCoords ( - xx1 yy1 xx2 yy2 )
  198.     xx1Dot @ xx1 +!    yy1Dot @ yy1 +!
  199.     xx2Dot @ xx2 +!    yy2Dot @ yy2 +!
  200.  
  201.     xx1 @ 1 WWidth @ RANGE NOT
  202.     IF xx1Dot @ NEGATE xx1Dot !
  203.     THEN
  204.  
  205.     yy1 @ 1 WHeight @ RANGE NOT
  206.     IF yy1Dot @ NEGATE yy1Dot !
  207.     THEN
  208.  
  209.     xx2 @ 1 WWidth @ RANGE NOT
  210.     IF xx2Dot @ NEGATE xx2Dot !
  211.     THEN
  212.  
  213.     yy2 @ 1 WHeight @ RANGE NOT
  214.     IF yy2Dot @ NEGATE yy2Dot !
  215.     THEN ;
  216.     
  217. \ Leaves 40 coordinate pairs on the stack and draws the 
  218. \ 1st 20 lines.
  219. : First20Lines (  -  )
  220.     #20 0 DO
  221.         Reflections    CALL SetPort
  222.         PatCopy        CALL PenMode
  223.         NewCoords 4DUP
  224.         CALL MoveTo    CALL LineTo
  225.     LOOP ;
  226.  
  227. : LinesForever (  -  )
  228.     BEGIN
  229.         Reflections    CALL SetPort
  230.         PatCopy        CALL PenMode
  231.         NewCoords 4DUP
  232.         CALL MoveTo
  233.         CALL LineTo ( 21 complete sets on => 84 values)
  234.  
  235.         #83 ROLL #83 ROLL #83 ROLL #83 ROLL
  236.         PatBic CALL PenMode ( and white out the n-21st line)
  237.         CALL MoveTo     CALL LineTo
  238.     exit?    AGAIN  ;
  239.         
  240. : Reflect (  -  )  SetUpReflect  First20Lines  LinesForever ;
  241.     
  242. : InitMBar (  -  )
  243.     ReflectMBar     ADD
  244.     ReflectMBar AppleMenu ADD
  245.     ReflectMBar FileMenu ADD
  246.     AppleMenu @ 'DRVR' CALL ADDRESMENU
  247.     ReflectMBar @ CALL SetMenuBar
  248.     CALL DrawMenuBar ;
  249.     
  250. : InitStructures (  -  )
  251.     Reflections ADD
  252.     Reflections CALL SelectWindow
  253.     Reflections GetWCoords
  254.     Reflections LinesTask BUILD 
  255.     InitMBar    ;
  256.  
  257. : Run ( taskptr -  )
  258.     ACTIVATE
  259.     ['] MbarHandler MENU-VECTOR !
  260.     ReflectMBar LinesTask MBAR>TASK
  261.     Reflect ;        
  262.  
  263. : BootLines (  -  )   InitStructures  LinesTask  Run  ; 
  264.